AROP

AROP:
- ✅ vzít ekvivalizované příjmy domácností
- ✅ přepočítat je na příjmy v PPP/PPS (srovnatelnou currency z hlediska, co si za ní koupíš)
- ✅ spočítat 60 % evropského mediánu
- ✅ spočítat, kolik domácností v různých zemí je pod
- ✅ jak se to liší od běžné AROP národní
- ✅ focus na ČR - jak se české a evropské AROP liší v různých typech domácností
- nice to haves:
- jak se tím změní AROPE - ukazatel, který zahrnuje AROP OR těžká materiální deprivace OR dlouhodobá nezaměstnanost, a v poslední dobe je používanější a vytvuří zdání robustnosti, ale je destruován tím AROP
- ✅ jak se změní vývoj v čase - zvětšuje se evropská chudoba v ČR (např. proti roku 2018, 2019)

Power Purchasing Parity je odsud.

V SILCu jsou příjmy domácností v eurech, pro země, které nepřijaly euro, je potřeba převést příjmy do národní měny. Měnové kurzy jsou odsud.

library(gt)
library(DT)
library(paqr)
library(dplyr)
library(corrr)
library(Hmisc)
library(haven)
library(readxl)
library(eulerr)
library(ggtext)
library(targets)
library(ggplot2)
library(ggrepel)
library(ggridges)
library(DescTools)
library(patchwork)

tar_load(r_silc_2023)

hh_r_silc_2023 <- r_silc_2023 %>% 
  group_by(country, hh_id) %>% 
  mutate(
    n_retired = sum(econ_status == "Retired", na.rm = TRUE), 
    n_employed = sum(econ_status == "Employed", na.rm = TRUE), 
    n_adults = sum(age >= 18), 
    n_old_age = sum(age >= 65),
    income_disposable = if_else(income_disposable < 0, 0, income_disposable),  
    income_disposable_eqi = if_else(income_disposable_eqi < 0, 0, income_disposable_eqi)
  ) %>% 
  slice(1) %>% 
  ungroup() %>% 
  mutate(across(where(is.character), ~haven::as_factor(.x))) %>% 
  # filter out EU countries only
  filter(country != "Norway") %>% 
  mutate(
    country = fct_case_when(
      country == "Oesterreich" ~ "Austria",
      country == "Belgique" ~ "Belgium",
      country == "Deutschland" ~ "Germany",
      country == "Danmark" ~ "Denmark",
      country == "Ellada" ~ "Greece",
      country == "Espana" ~ "Spain",
      country == "Suomi" ~ "Finland",
      country == "Nederland" ~ "Netherlands",
      country == "Sverige" ~ "Sweden", 
      country == "Italia" ~ "Italy",
      country == "Czech Republic" ~ "Czechia",
      country == "Slovak Republic" ~ "Slovakia",
      TRUE ~ country
    ), 
    r_tenure_status = fct_case_when(
      grepl("Tenant", tenure_status) ~ "Tenant", 
      grepl("Owner", tenure_status) ~ "Owner"
    )
  ) %>% 
  mutate(
    hh_retired = fct_case_when(
      n_retired == n_persons ~ "Plně důchodcovská domácnost", 
      n_retired > 0 ~ "Domácnost s důchodcem",
      n_retired == 0 ~ "Domácnost bez důchodců"
    ), 
    hh_old = fct_case_when(
      n_old_age == n_persons ~ "Všichni 65+",
      n_old_age > 0 ~ "Alespoň jeden 65+",
      n_old_age == 0 ~ "Bez 65+"
    ),
    typ_domacnosti = fct_case_when(
      n_adults == 2 & n_children > 0 ~ "Úplná domácnost s dětmi",
      n_adults == 1 & n_children > 0 ~ "Samoživitel/ka s dětmi",
      n_adults == 2 & hh_retired == "Plně důchodcovská domácnost" ~ "Dvojice seniorů",
      n_adults == 1 & hh_retired == "Plně důchodcovská domácnost" ~ "Samostatně žijící senior",
      TRUE ~ "Ostatní"
    )
  )

regiony <- hh_r_silc_2023 %>% 
  filter(region != "info not provided for DE, NL, PT, RS") %>% 
  group_by(country, region) %>% 
  summarise(mean_income = mean(income_disposable_eqi)) %>% 
  group_by(country) %>% 
  filter(mean_income == max(mean_income) | mean_income == min(mean_income)) %>% 
  mutate(
    n = n(), 
    region_typ = case_when(
      mean_income == max(mean_income) ~ "nejbohatší region", 
      mean_income == min(mean_income) ~ "nejchudší region"
    )
  ) %>% 
  filter(n == 2) %>% 
  ungroup %>% 
  select(country, region, region_typ)
  
exchange_rates <- read_excel("data/exchange_rates.xlsx", sheet = 3, skip = 8) %>% 
  select(currency = TIME, exchange_rate_2022 = `2022`) %>% 
  filter(!is.na(currency)) %>% 
  mutate(country = case_when(
    currency == "Bulgarian lev" ~ "Bulgaria",
    currency == "Czech koruna" ~ "Czechia",
    currency == "Danish krone" ~ "Denmark",
    currency == "Hungarian forint" ~ "Hungary",
    currency == "Polish zloty" ~ "Poland",
    currency == "Romanian leu" ~ "Romania",
    currency == "Swedish krona" ~ "Sweden"
  )) %>% 
  filter(!is.na(country)) %>% 
  mutate(exchange_rate_2022 = as.numeric(exchange_rate_2022))

ppp_data <- read_excel("data/power_purchasing_parity_2decimals.xlsx") %>% 
  select(country = Country, ppp_2022 = `2022`)

ppp_adjusted <- left_join(ppp_data, exchange_rates, by = "country") %>% 
  mutate(ppp_2022_adjusted = if_else(
    !is.na(exchange_rate_2022), 
    ppp_2022 / exchange_rate_2022,
    ppp_2022
  )) %>% 
  select(country, ppp_2022_adjusted) 

hh_r_silc_2023_ppp <- left_join(hh_r_silc_2023, ppp_adjusted, by = "country") %>% 
  mutate(
    income_disposable_eqi_ppp = income_disposable_eqi / ppp_2022_adjusted
  ) %>% 
  left_join(., regiony, by = c("country", "region"))

EU_MEDIAN_PPP <- wtd.quantile(hh_r_silc_2023_ppp$income_disposable_eqi_ppp,
                              hh_r_silc_2023_ppp$hh_cross_weight, 0.5)  
EU_MEDIAN_60PCT <- EU_MEDIAN_PPP * 0.6
EU_MEDIAN_50PCT <- EU_MEDIAN_PPP * 0.5
EU_MEDIAN_70PCT <- EU_MEDIAN_PPP * 0.7

hh_r_silc_2023_arop <- hh_r_silc_2023_ppp %>% 
  mutate(
    under_arop = income_disposable_eqi_ppp < EU_MEDIAN_60PCT, 
    under_eu_poverty = income_disposable_eqi_ppp < EU_MEDIAN_50PCT, 
    under_eu_70_boundary = income_disposable_eqi_ppp < EU_MEDIAN_70PCT, 
    r_country = if_else(country == "Czechia", "Česko", "zbytek EU")
  )

eu_arop_2023b <- hh_r_silc_2023_arop %>% 
  group_by(r_country) %>% 
  summarise(
    pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100, 
    pct_under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight, na.rm = TRUE) * 100  
  )

eu_arop_2023b %>% 
  arrange(pct_under_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median"))
Country % under EU AROP % under 50% of EU median
zbytek EU 19.25 12.82
Česko 21.68 10.35
eu_arop_2023 <- hh_r_silc_2023_arop %>% 
  group_by(country) %>% 
  summarise(
    pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100, 
    pct_under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight, na.rm = TRUE) * 100)

eu_arop_2023 %>% 
  arrange(pct_under_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median"))
Country % under EU AROP % under 50% of EU median
Luxembourg 3.12 2.38
Belgium 3.96 2.10
Ireland 4.73 2.40
Austria 6.43 4.10
Denmark 7.45 4.35
Netherlands 7.49 4.98
Finland 10.35 4.93
Germany 10.84 6.51
France 11.14 6.61
Cyprus 13.87 5.85
Slovenia 14.79 7.12
Sweden 15.21 9.71
Malta 17.39 9.63
Italy 17.92 11.75
Spain 20.14 12.79
Czechia 21.68 10.35
Poland 26.87 16.66
Portugal 37.70 25.59
Estonia 39.24 30.21
Lithuania 41.26 30.83
Croatia 42.35 31.80
Latvia 46.01 37.06
Greece 48.06 34.05
Slovakia 51.33 30.90
Romania 51.73 38.96
Hungary 55.85 42.35
Bulgaria 59.87 49.22
hh_r_silc_2023_arop |> 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100)
## # A tibble: 1 × 1
##   pct_under_arop
##            <dbl>
## 1           19.3

Srovnání EU vs. národní AROP

national_medians <- hh_r_silc_2023_ppp %>% 
  group_by(country) %>% 
  summarise(median_income = wtd.quantile(income_disposable_eqi_ppp, 
                                         hh_cross_weight, 0.5), 
            .groups = "drop") %>% 
  mutate(
    national_70_boundary = median_income * 0.7,
    national_arop_boundary = median_income * 0.6, 
    national_poverty_boundary = median_income * 0.5
  )

hh_r_silc_2023_national_arop <- full_join(hh_r_silc_2023_arop, national_medians, 
                                          by = "country") %>% 
  mutate(
    under_70_boundary = income_disposable_eqi_ppp < national_70_boundary,
    under_national_arop = income_disposable_eqi_ppp < national_arop_boundary,
    under_national_poverty = income_disposable_eqi_ppp < national_poverty_boundary, 
    r_country = if_else(country == "Czechia", "Czechia", "Rest of EU")
  )
  
eu_national_arop <- hh_r_silc_2023_national_arop %>% 
  group_by(r_country) %>% 
  summarise(pct_under_national_arop = wtd.mean(
    under_national_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  left_join(eu_arop_2023b, ., by = "r_country")

eu_national_arop %>% 
  arrange(pct_under_national_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median",
                                            "% under national AROP"))
Country % under EU AROP % under 50% of EU median % under national AROP
zbytek EU 19.25 12.82 NA
Česko 21.68 10.35 NA
eu_national_arop <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(pct_under_national_arop = wtd.mean(
    under_national_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  left_join(eu_arop_2023, ., by = "country")

eu_national_arop %>% 
  arrange(pct_under_national_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median",
                                            "% under national AROP"))
Country % under EU AROP % under 50% of EU median % under national AROP
Czechia 21.68 10.35 9.80
Belgium 3.96 2.10 10.20
Finland 10.35 4.93 12.69
Hungary 55.85 42.35 12.80
Denmark 7.45 4.35 12.83
Slovakia 51.33 30.90 13.29
Netherlands 7.49 4.98 14.56
Ireland 4.73 2.40 14.82
France 11.14 6.61 14.87
Cyprus 13.87 5.85 15.04
Slovenia 14.79 7.12 15.06
Poland 26.87 16.66 15.24
Austria 6.43 4.10 15.49
Germany 10.84 6.51 15.59
Bulgaria 59.87 49.22 16.24
Sweden 15.21 9.71 16.31
Portugal 37.70 25.59 17.47
Luxembourg 3.12 2.38 18.18
Greece 48.06 34.05 18.58
Italy 17.92 11.75 19.23
Romania 51.73 38.96 19.40
Malta 17.39 9.63 19.40
Spain 20.14 12.79 20.19
Lithuania 41.26 30.83 21.92
Croatia 42.35 31.80 22.30
Latvia 46.01 37.06 24.52
Estonia 39.24 30.21 25.58
ggplot(eu_national_arop, aes(x = pct_under_national_arop, y = pct_under_arop)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_x_continuous(labels = scales::label_percent(scale = 1)) + 
  geom_smooth(se = FALSE, method = "lm") +
  theme_paq() + 
  labs(x = "% under (national) AROP", y = "% under EU AROP") 

country_median_income_ppp <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(median_income_ppp = median(income_disposable_eqi_ppp)) %>% 
  arrange(desc(median_income_ppp))

hh_r_silc_2023_national_arop %>% 
  ggplot(aes(x = factor(country, levels = rev(country_median_income_ppp$country)), 
             y = income_disposable_eqi_ppp)) + 
  geom_boxplot(outliers = FALSE) + 
  geom_point(data = national_medians, aes(x = country, y = national_arop_boundary), 
             colour = "blue", shape = 3) + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") + 
  theme_paq() + 
  coord_flip() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS", 
       caption = "Modrý kříž indikuje národní hranici chudoby (60 % národního mediánu)")
chart_data <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>%
  summarise(q90 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.90), 
            q10 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.10)) %>%
  ungroup %>% 
  left_join(., national_medians, by = "country") %>% 
  mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))

chart_data %>% 
  ggplot() + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                xmax = as.numeric(country) + 0.4, 
                ymin = q10, ymax = q90), 
            alpha = 0.5) +
  scale_x_continuous(
    breaks = 1:nlevels(chart_data$country),
    labels = levels(chart_data$country)
  ) +
  scale_y_continuous(limits = c(0, NA)) + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                     xmax = as.numeric(country) + 0.4,
                     ymin = national_arop_boundary,
                     ymax = national_arop_boundary), 
                 colour = "blue") + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
  coord_flip() + 
  theme_paq() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")
chart_data <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>%
  summarise(q50 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.50), 
            q01 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.01)) %>%
  ungroup %>% 
  left_join(., national_medians, by = "country") %>% 
  mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))

chart_data %>% 
  ggplot() + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                xmax = as.numeric(country) + 0.4, 
                ymin = q01, ymax = q50), 
            alpha = 0.5) +
  scale_x_continuous(
    breaks = 1:nlevels(chart_data$country),
    labels = levels(chart_data$country)
  ) +
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                     xmax = as.numeric(country) + 0.4,
                     ymin = national_arop_boundary,
                     ymax = national_arop_boundary), 
                 colour = "blue") + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
  coord_flip() + 
  theme_paq() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")
chart_data_1_99 <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>%
  summarise(q99 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.99), 
            q01 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.01)) %>%
  ungroup %>% 
  left_join(., national_medians, by = "country") %>% 
  mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))

chart_data_1_99 %>% 
  ggplot() + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                xmax = as.numeric(country) + 0.4, 
                ymin = q01, ymax = q99), 
            alpha = 0.5) +
  scale_x_continuous(
    breaks = 1:nlevels(chart_data$country),
    labels = levels(chart_data$country)
  ) +
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                     xmax = as.numeric(country) + 0.4,
                     ymin = national_arop_boundary,
                     ymax = national_arop_boundary), 
                 colour = "blue") + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
  coord_flip() + 
  theme_paq() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")
hh_r_silc_2023_national_arop %>% 
  filter(country == "Czechia") %>% 
  pull (income_disposable_eqi_ppp) %>% 
  density() -> m_dens

country_q95 <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(q95 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.95))

countries <- unique(hh_r_silc_2023_national_arop$country)
density_df <- purrr::map_df(countries, function(x) {
  country <- x
  tmp <- hh_r_silc_2023_national_arop %>% 
    filter(country == x)
  
  national_arop_boundary <- unique(tmp$national_arop_boundary)
  
  dens <- density(tmp$income_disposable_eqi_ppp, n = 50000)
  
  tibble(
    x = dens$x, 
    y = dens$y, 
    under_national_arop = x < national_arop_boundary, 
    country = country
  )
})

CZ_MEDIAN_60PCT <- national_medians |> 
  filter(country == "Czechia") |> 
  pull(national_arop_boundary)

density_df %>% 
  left_join(., country_q95, by = "country") %>% 
  filter(x <= q95) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    ), 
    under_national_arop = factor(under_national_arop, 
                                 levels = c(TRUE, FALSE), 
                                 labels = c("Pod 60 % mediánu národního příjmu", 
                                            "Nad 60 % mediánu"))
  ) %>% 
  ggplot(., aes(x = x, y = country,
                height = y * 10000, fill = under_national_arop)) + 
  # geom_vline(xintercept = EU_MEDIAN_60PCT, colour = "red") + 
  # geom_vline(xintercept = EU_MEDIAN_50PCT, colour = "darkred") + 
  # geom_vline(xintercept = CZ_MEDIAN_60PCT, colour = "blue") + 
  geom_ridgeline_gradient() + 
  scale_x_continuous(limits = c(0, 75000), labels = scales::comma_format(big.mark = " ")) + 
  scale_fill_manual(values = c("Pod 60 % mediánu národního příjmu" = "#ECB925", 
                               "Nad 60 % mediánu" = "gray80")) + 
  theme_paq() + 
  # theme(legend.position = "none") + 
  labs(x = "Ekvivalizovaný příjem domácnosti ve standardu kupní síly", y = ""
      #  caption = "Distribuce nezobrazují hodnoty nad 95. percentil v daném státu. Modrá svislice ukazuje českou hranici chudoby,\ntmavě červená 50 % evropského mediánu, červená evropskou hranici chudoby (60 % mediánu)."
       )

save_plot(plot = last_plot(),
          path = "figs/arop/arop1.png", 
          height_px = 600, 
          width_px = 600)

Kolik by bylo v evropských státech pod českou hranicí chudoby

hh_r_silc_2023_national_arop |> 
  group_by(country) |> 
  mutate(under_cz_arop = income_disposable_eqi_ppp < CZ_MEDIAN_60PCT) |> 
  summarise(under_cz_arop = wtd.mean(under_cz_arop, hh_cross_weight, na.rm = TRUE) * 100) |> 
  arrange(under_cz_arop) |> 
  knitr::kable(col.names = c("Country", "% under CZ poverty line"))
Country % under CZ poverty line
Belgium 2.045642
Ireland 2.254960
Luxembourg 2.377036
Austria 4.031356
Denmark 4.149577
Finland 4.593589
Netherlands 4.946518
Cyprus 5.458738
Germany 6.268019
France 6.385330
Slovenia 6.921078
Malta 9.326997
Sweden 9.475918
Czechia 9.803617
Italy 11.274460
Spain 12.459903
Poland 16.022737
Portugal 24.701623
Slovakia 29.314007
Estonia 29.366123
Lithuania 30.124821
Croatia 31.054021
Greece 32.842150
Latvia 36.504372
Romania 37.551559
Hungary 41.150338
Bulgaria 48.173245

Jak moc to souvisí s materiální a sociální deprivací

AROPE (Ohrožení chudobou nebo sociálním vyloučením)

AROPE = (AROP | nízká pracovní intenzita | vážná materiální nebo sociální deprivace)

  • vážná materiální a sociální deprivace = alespoň 7 ze 13 položek týkající se deprivace (6 ohledně jednotlivce, 7 za domácnost)
  • AROP
  • velmi nízká pracovní intenzita (pro domácnosti tvořené dospělými ve věku 18-64) = dospělí pracovovali méně než 20% jejich pracovního potenciálu
hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(
    severely_deprived = wtd.mean(severe_material_social_deprivation, hh_cross_weight)
  )
## # A tibble: 27 × 2
##    country  severely_deprived
##    <chr>                <dbl>
##  1 Austria             0.0407
##  2 Belgium             0.0703
##  3 Bulgaria            0.192 
##  4 Croatia             0.0422
##  5 Cyprus              0.0299
##  6 Czechia             0.0283
##  7 Denmark             0.0600
##  8 Estonia             0.0277
##  9 Finland             0.0385
## 10 France              0.0713
## # ℹ 17 more rows
hh_r_silc_2023_national_arop %>% 
  filter(low_work_intensity != 2) %>% 
  group_by(country) %>% 
  summarise(
    low_work_intensity = wtd.mean(low_work_intensity, hh_cross_weight)
  )
## # A tibble: 27 × 2
##    country  low_work_intensity
##    <chr>                 <dbl>
##  1 Austria              0.0752
##  2 Belgium              0.139 
##  3 Bulgaria             0.0757
##  4 Croatia              0.0506
##  5 Cyprus               0.0533
##  6 Czechia              0.0553
##  7 Denmark              0.150 
##  8 Estonia              0.0786
##  9 Finland              0.124 
## 10 France               0.104 
## # ℹ 17 more rows
hh_r_silc_2023_national_arop %>% 
  mutate(arope = under_national_arop | 
           low_work_intensity == 1 | 
           severe_material_social_deprivation == 1) %>% 
  group_by(country) %>% 
  summarise(
    pct_arope = wtd.mean(arope, hh_cross_weight), 
    pct_national_arop = wtd.mean(under_national_arop, hh_cross_weight)
  ) %>% 
  ggplot(., aes(x = pct_arope, y = pct_national_arop)) + 
  # geom_abline(slope = 1, colour = "black") + 
  geom_smooth(method = "lm", se = FALSE, colour = "gray80") + 
  geom_text_repel(aes(label = country)) + 
  geom_point() + 
  scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  theme_paq() + 
  coord_equal() + 
  labs(x = "Podíl domácností v ohrožení chudobou a sociálním vyloučením", 
       y = "Podíl domácností v ohrožení chudobou")

hh_r_silc_2023_national_arop |> 
  ggplot(aes(x = sum_deprived_items)) + 
  geom_histogram(aes(y = ..density..), bins = 14) + 
  facet_wrap(~country) + 
  theme_paq()

aropes <- hh_r_silc_2023_national_arop %>% 
  mutate(arope = under_national_arop | 
           low_work_intensity == 1 | 
           severe_material_social_deprivation == 1, 
         eu_arope = under_eu_poverty | 
           low_work_intensity == 1 | 
           severe_material_social_deprivation == 1) %>% 
  group_by(country) %>% 
  summarise(
    pct_eu_arope = wtd.mean(eu_arope, hh_cross_weight), 
    pct_national_arope = wtd.mean(arope, hh_cross_weight)
  ) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) 

aropes %>% 
  ggplot(., aes(x = pct_eu_arope, y = pct_national_arope)) + 
  geom_smooth(method = "lm", se = FALSE, colour = "gray80") + 
  geom_text_repel(aes(label = country)) + 
  geom_point() + 
  scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  theme_paq() + 
  coord_equal() + 
  labs(x = "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
       y = "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením")

cntry_levels <- aropes |> arrange(pct_eu_arope) |> pull(country)
aropes %>% 
  tidyr::pivot_longer(cols = c(pct_eu_arope, pct_national_arope)) %>% 
  mutate(name = case_when(
    name == "pct_eu_arope" ~ "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
    name == "pct_national_arope" ~ "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením"
  ), 
    country = factor(country, levels = rev(cntry_levels))
  ) %>% 
  ggplot(., aes(x = country, y = value, fill = name)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  coord_flip() + 
  theme_paq() + 
  guides(fill = guide_legend(nrow = 2)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "")

save_plot(plot = last_plot(),
          path = "figs/arop/aropes.png", 
          height_px = 600, 
          width_px = 600)

Za kolik z AROPE může AROP, deprivace, nízká pracovní aktivita

AROPE s národní hranicí
national_arope_data <- hh_r_silc_2023_national_arop |> 
  mutate(type = fct_case_when(
    under_national_arop ~ "Pod národní hranicí chudoby",
    severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
    low_work_intensity == 1 ~ "Nízká pracovní intenzita", 
    TRUE ~ "není v AROPE", 
    new_levels = c("není v AROPE", "Nízká pracovní intenzita", "Vážně materiálně či sociálně deprivovaný", "Pod národní hranicí chudoby")
  ), 
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  )

eu_arope_split <- national_arope_data |> 
  group_by(type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  ungroup() |> 
  mutate(pct = n / sum(n), 
         country = "EU")

arope_split <- national_arope_data |> 
  group_by(country, type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

arope_split_countries <- arope_split |> 
  filter(type == "není v AROPE") |> 
  arrange(desc(pct)) |> 
  pull(country)

arope_split |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = arope_split_countries)) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = paleta_kategoricka(3)) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE)) + 
  theme(panel.grid.major.y = element_blank())

save_plot(last_plot(), "figs/arop/arop_composition.png")
arope_split |> 
  bind_rows(eu_arope_split) |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = c(as.character(arope_split_countries), "EU"))) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = rev(paleta_kategoricka(3))) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE))

save_plot(last_plot(), "figs/arop/arop_composition_w_eu.png")
heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    national_arop = fct_case_when(
      under_national_arop ~ "Pod národní hranicí chudoby", 
      TRUE ~ "Nad národní hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    ),
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) |> 
  group_by(country, national_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

heatmap_data |> 
  filter(!(deprivation == "Není vážně deprivovaný" & national_arop == "Nad národní hranicí chudoby" & work_intensity == "Dostatečná pracovní intenzita")) |> 
  ggplot(aes(x = work_intensity, y = country, fill = pct)) + 
  geom_tile() + 
  facet_wrap(deprivation ~ national_arop)

library(ggupset)

upset_chart_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    national_arop = case_when(
      under_national_arop ~ "Pod národní hranicí chudoby", 
      TRUE ~ NA
    ),
    deprivation = case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ NA
    ),
    work_intensity = case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ NA
    ),
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) |> 
  select(hh_id, country, hh_cross_weight, national_arop, deprivation, work_intensity) |> 
  tidyr::pivot_longer(cols = c(national_arop, deprivation, work_intensity)) |> 
  group_by(hh_id, country) |> 
  summarise(
    characteristics = list(value), .groups = "drop", 
    hh_cross_weight = unique(hh_cross_weight)
  ) |> 
  group_by(country, characteristics) |> 
  summarise(n = sum(hh_cross_weight), .groups = "drop") |> 
  group_by(country) |> 
  mutate(
    pct = n / sum(n), 
    n_nas = purrr::map_int(characteristics, ~sum(is.na(.x)))
  ) |> 
  # filter(country == "Česko") |> 
  filter(n_nas != 3)

upset_chart_data |> 
  filter(country == "Česko") |> 
  ggplot(aes(x = characteristics, y = pct)) + 
  geom_bar(stat = "identity") + 
  scale_x_upset() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  labs(x = "", y = "% domácností") + 
  theme_paq() + 
  theme(plot.margin = margin(2, 2, 2, 150))

upset_chart_data |> 
  ggplot(aes(x = characteristics, y = pct)) + 
  geom_bar(stat = "identity") + 
  scale_x_upset() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), limits = c(0, 0.21)) + 
  facet_wrap(~country, ncol = 5) + 
  theme_paq()

create_euler_data <- function(df, cntry){
  c(
  "Pod hranicí chudoby" = df |> 
  filter(country == !!cntry) |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         deprivation == "Není vážně deprivovaný",
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         work_intensity == "Nízká pracovní intenzita", 
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita" = df |>
  filter(country == !!cntry) |>  
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          national_arop == "Pod národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)
}

countries <- unique(heatmap_data$country)

euler_charts <- purrr::map(countries, function(x) {
  euler_df <- create_euler_data(heatmap_data, x)
  fit <-euler(euler_df, shape = "ellipse")
  plot(fit, quantities = TRUE, main = as.character(x), labels = FALSE)  
})

euler_mega_chart <- gridExtra::grid.arrange(
  euler_charts[[1]], euler_charts[[2]], euler_charts[[3]],
  euler_charts[[4]], euler_charts[[5]],
  euler_charts[[6]], euler_charts[[7]], euler_charts[[8]],
  euler_charts[[9]], euler_charts[[10]],
  euler_charts[[11]], euler_charts[[12]], euler_charts[[13]],
  euler_charts[[14]], euler_charts[[15]],
  euler_charts[[16]], euler_charts[[17]], euler_charts[[18]],
  euler_charts[[19]], euler_charts[[20]],
  euler_charts[[21]], euler_charts[[22]], euler_charts[[23]],
  euler_charts[[24]], euler_charts[[25]],
  euler_charts[[26]], euler_charts[[27]],
  ncol = 5
)

save_plot(euler_mega_chart, "figs/arop/euler_diagrams.png", width_px = 1000, height_px = 1000)
all_countries_heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    national_arop = fct_case_when(
      under_national_arop ~ "Pod národní hranicí chudoby", 
      TRUE ~ "Nad národní hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    )
  ) |> 
  group_by(national_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> ungroup() |> 
  mutate(pct = n / sum(n))

eu_euler <- 
  c(
  "Pod hranicí chudoby" = all_countries_heatmap_data |> ungroup() |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = all_countries_heatmap_data |> ungroup() |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         deprivation == "Není vážně deprivovaný",
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         work_intensity == "Nízká pracovní intenzita", 
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita" = all_countries_heatmap_data |> ungroup() |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          national_arop == "Pod národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)

eu_fit <- euler(eu_euler, shape = "ellipse")
AROPE s evropskou hranicí
arope_split2_data <- hh_r_silc_2023_national_arop |> 
  mutate(type = fct_case_when(
    under_arop ~ "Pod evropskou hranicí chudoby",
    severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
    low_work_intensity == 1 ~ "Nízká pracovní intenzita", 
    TRUE ~ "není v AROPE", 
    new_levels = c("není v AROPE", "Nízká pracovní intenzita", "Vážně materiálně či sociálně deprivovaný", "Pod evropskou hranicí chudoby")
  ), 
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) 
  
arope_split2 <- arope_split2_data |> 
  group_by(country, type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

eu_arope_split2 <- arope_split2_data |> 
  group_by(type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  ungroup() |> 
  mutate(pct = n / sum(n), 
         country = "EU")

arope_split_countries2 <- arope_split2 |> 
  filter(type == "není v AROPE") |> 
  arrange(desc(pct)) |> 
  pull(country)

arope_split2 |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = arope_split_countries2)) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = rev(paleta_kategoricka(3))) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE))

save_plot(last_plot(), "figs/arop/eu_arop_composition.png")
arope_split2 |> 
  bind_rows(eu_arope_split2) |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = c(as.character(arope_split_countries2), "EU"))) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = rev(paleta_kategoricka(3))) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE))

save_plot(last_plot(), "figs/arop/eu_arop_composition_w_eu.png")
eu_heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    eu_arop = fct_case_when(
      under_arop ~ "Pod evropskou hranicí chudoby", 
      TRUE ~ "Nad evropskou hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    ),
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) |> 
  group_by(country, eu_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

create_eu_euler_data <- function(df, cntry){
  c(
  "Pod hranicí chudoby" = df |> 
  filter(country == !!cntry) |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita" = df |>
  filter(country == !!cntry) |>  
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          eu_arop == "Pod evropskou hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)
}

countries <- unique(eu_heatmap_data$country)

eu_euler_charts <- purrr::map(countries, function(x) {
  euler_df <- create_eu_euler_data(eu_heatmap_data, x)
  fit <-euler(euler_df, shape = "ellipse")
  plot(fit, quantities = TRUE, main = as.character(x), labels = FALSE)  
})

eu_euler_mega_chart <- gridExtra::grid.arrange(
  eu_euler_charts[[1]], eu_euler_charts[[2]], eu_euler_charts[[3]],
  eu_euler_charts[[4]], eu_euler_charts[[5]],
  eu_euler_charts[[6]], eu_euler_charts[[7]], eu_euler_charts[[8]],
  eu_euler_charts[[9]], eu_euler_charts[[10]],
  eu_euler_charts[[11]], eu_euler_charts[[12]], eu_euler_charts[[13]],
  eu_euler_charts[[14]], eu_euler_charts[[15]],
  eu_euler_charts[[16]], eu_euler_charts[[17]], eu_euler_charts[[18]],
  eu_euler_charts[[19]], eu_euler_charts[[20]],
  eu_euler_charts[[21]], eu_euler_charts[[22]], eu_euler_charts[[23]],
  eu_euler_charts[[24]], eu_euler_charts[[25]],
  eu_euler_charts[[26]], eu_euler_charts[[27]],
  ncol = 5
)

save_plot(eu_euler_mega_chart, "figs/arop/euler_eu_diagrams.png", 
          width_px = 1000, height_px = 1000)
all_countries_eu_heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    eu_arop = fct_case_when(
      under_arop ~ "Pod evropskou hranicí chudoby", 
      TRUE ~ "Nad evropskou hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    )
  ) |> 
  group_by(eu_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> ungroup() |> 
  mutate(pct = n / sum(n))

all_countries_euler_df <- c(
  "Pod EU hranicí chudoby" = all_countries_eu_heatmap_data |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = all_countries_eu_heatmap_data |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod EU hranicí chudoby&Nízká pracovní\nintenzita" = all_countries_eu_heatmap_data |>
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod EU hranicí chudoby&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod EU hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          eu_arop == "Pod evropskou hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)

fit <-euler(all_countries_euler_df, shape = "ellipse")
plot(fit, quantities = TRUE, main = "EU", labels = TRUE)  

Bez indikátoru “nemůže si dovolit nečekané výdaje ve výši 60% mediánového příjmu”

aropes2 <- hh_r_silc_2023_national_arop %>% 
  mutate(arope = under_national_arop | 
           low_work_intensity == 1 | 
           sum_deprived_items_wo_expenses > 6, 
         eu_arope = under_eu_poverty | 
           low_work_intensity == 1 | 
           sum_deprived_items_wo_expenses > 6) %>% 
  group_by(country) %>% 
  summarise(
    pct_eu_arope = wtd.mean(eu_arope, hh_cross_weight), 
    pct_national_arope = wtd.mean(arope, hh_cross_weight)
  ) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) 

aropes2 %>% 
  ggplot(., aes(x = pct_eu_arope, y = pct_national_arope)) + 
  geom_smooth(method = "lm", se = FALSE, colour = "gray80") + 
  geom_text_repel(aes(label = country)) + 
  geom_point() + 
  scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  theme_paq() + 
  labs(x = "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
       y = "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením")

cntry_levels <- aropes2 |> arrange(pct_eu_arope) |> pull(country)
aropes2 %>% 
  tidyr::pivot_longer(cols = c(pct_eu_arope, pct_national_arope)) %>% 
  mutate(name = case_when(
    name == "pct_eu_arope" ~ "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
    name == "pct_national_arope" ~ "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením"
  ), country = factor(country, levels = rev(cntry_levels))) %>% 
  ggplot(., aes(x = country, y = value, fill = name)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  coord_flip() + 
  theme_paq() + 
  guides(fill = guide_legend(nrow = 2)) + 
  labs(x = "", y = "")

save_plot(last_plot(), 
          "figs/arop/arope_bez_indikatoru.png")
arop_deprivation <- hh_r_silc_2023_national_arop |> 
  group_by(country) |> 
  summarise(
    under_national_arop = wtd.mean(under_national_arop, hh_cross_weight) * 100, 
    under_eu_arop = wtd.mean(under_arop, hh_cross_weight) * 100, 
    material_deprivation = wtd.mean(severe_material_social_deprivation, hh_cross_weight) * 100
  ) |> 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  )

cor(arop_deprivation$under_national_arop, arop_deprivation$material_deprivation)
## [1] 0.105053
cor(arop_deprivation$under_eu_arop, arop_deprivation$material_deprivation)
## [1] 0.5996177
r2_label <- tibble(
  x = 10, 
  y = 20, 
  label = "r<sup>2</sup>=0.01"
)

chart_national_depr <- ggplot(arop_deprivation, aes(x = under_national_arop, y = material_deprivation)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  geom_richtext(aes(x = x, y = y, label = label), 
                data = r2_label, hjust = 0, 
                fill = NA, label.colour = NA) + 
  geom_smooth(method = "lm", se = FALSE) + 
  scale_y_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
  scale_x_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) + 
  # coord_equal() + 
  theme_paq() + 
  labs(x = "% domácností pod národní hranicí chudoby", 
       y = "% domácností ve vážné materiální nebo sociální deprivaci")

eu_r2_label <- tibble(
  x = 3.4, 
  y = 20, 
  label = "r<sup>2</sup>=0.36"
)

chart_eu_depr <- ggplot(arop_deprivation, aes(x = under_eu_arop, y = material_deprivation)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  geom_smooth(method = "lm", se = FALSE) + 
  geom_richtext(aes(x = x, y = y, label = label), 
                data = eu_r2_label, hjust = 0, 
                fill = NA, label.colour = NA) + 
  # coord_equal() + 
  scale_y_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
  scale_x_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) + 
  theme_paq() + 
  labs(x = "% domácností pod evropskou hranicí chudoby", 
       y = "% domácností ve vážné materiální nebo sociální deprivaci")

chart_national_depr | chart_eu_depr

save_plot(plot = last_plot(),
          path = "figs/arop/scatter_arop_deprivation.png")
eu_dens <- density(hh_r_silc_2023_national_arop$income_disposable_eqi_ppp, n = 50000)
eu_density_df <- tibble(
  country = "EU", 
  x = eu_dens$x, 
  y = eu_dens$y
)

density_df %>% 
  left_join(., country_q95, by = "country") %>% 
  filter(x <= q95) %>% 
bind_rows(
  ., 
  eu_density_df
) %>% 
  mutate(under_eu_arop = x < EU_MEDIAN_60PCT) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko", 
      country == "EU" ~ "EU"
    ), 
    under_eu_arop = factor(under_eu_arop, levels = c(TRUE, FALSE), 
    labels = c("Pod evropskou hranicí příjmové chudoby (60 % evropského mediánu)", "Nad evropskou hranicí chudoby"))  
  ) %>% 
  ggplot(., aes(x = x, y = country,
                height = y * 10000, fill = under_eu_arop)) + 
  geom_vline(xintercept = EU_MEDIAN_60PCT, colour = "red") + 
  geom_vline(xintercept = EU_MEDIAN_50PCT, colour = "darkred") + 
  # geom_vline(xintercept = CZ_MEDIAN_60PCT, colour = "blue") + 
  geom_ridgeline_gradient() + 
  scale_x_continuous(limits = c(0, 75000), labels = scales::comma_format(big.mark = " ")) + 
  scale_fill_manual(values = c("Pod evropskou hranicí příjmové chudoby (60 % evropského mediánu)" = "#ECB925", 
                               "Nad evropskou hranicí chudoby" = "gray80")) + 
  theme_paq() + 
  # theme(legend.position = "none") + 
  labs(x = "Ekvivalizovaný příjem domácnosti ve standardu kupní síly", y = "") + 
  geom_curve(x = 51000, xend = EU_MEDIAN_50PCT + 500, y = 24, yend = 27, 
            curvature = -0.05, colour = "darkred",
            arrow = arrow(length = unit(0.1, "cm"))) + 
  annotate("text", x = 62500, y = 24, label = "50 % evropského mediánu", 
           colour = "darkred") + 
  geom_curve(x = 51000, xend = EU_MEDIAN_60PCT + 500, y = 23, yend = 26, 
            curvature = -0.05, colour = "red",
            arrow = arrow(length = unit(0.1, "cm"))) + 
  annotate("text", x = 62500, y = 23, label = "60 % evropského mediánu", 
           colour = "red") +  
  guides(fill = guide_legend(nrow = 2))

save_plot(plot = last_plot(),
          path = "figs/arop/arop1_eu_arrows.png", 
          height_px = 600, 
          width_px = 600)
hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(
    under_national_arop = wtd.mean(under_national_arop, hh_cross_weight), 
    under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight), 
    under_eu_arop = wtd.mean(under_arop, hh_cross_weight)
  ) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko", 
      country == "EU" ~ "EU"
    )
  ) %>% 
  ggplot(., aes(x = under_national_arop, y = under_eu_poverty)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  geom_smooth(se = FALSE, method = "lm") + 
  scale_x_continuous(labels = scales::label_percent(scale = 100, suffix = " %")) + 
  scale_y_continuous(labels = scales::label_percent(scale = 100, suffix = " %")) + 
  theme_paq() + 
  labs(x = "Pod hranicí 60 % národního mediánu", 
       y = "Pod hranicí 50 % evropského mediánu")

save_plot(last_plot(), "figs/arop/arop_scatter.png", 
          width_px = 640, height_px = 640)

Materiální deprivace vs. národní AROP

hh_r_silc_2023_national_arop |> 
  filter(!is.na(sum_deprived_items)) |> 
  mutate(r_sum_deprived_items = fct_case_when(
    sum_deprived_items >= 10 ~ "10 a více", 
    sum_deprived_items >= 7 ~ "7-9", 
    sum_deprived_items >= 4 ~ "4-6",
    sum_deprived_items >= 3 ~ "3-5", 
    sum_deprived_items >= 1 ~ "1-2",
    sum_deprived_items == 0 ~ "0"
  )) |> 
  group_by(country, r_sum_deprived_items, under_national_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, r_sum_deprived_items) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = r_sum_deprived_items, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_national_arop) |> 
  ggplot(aes(x = under_national_arop, y = sum_deprived_items, fill = under_national_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

Materiální deprivace vs. evropský AROP

hh_r_silc_2023_national_arop |> 
  filter(!is.na(sum_deprived_items)) |> 
  mutate(r_sum_deprived_items = fct_case_when(
    sum_deprived_items >= 10 ~ "10 a více", 
    sum_deprived_items >= 7 ~ "7-9", 
    sum_deprived_items >= 4 ~ "4-6",
    sum_deprived_items >= 3 ~ "3-5", 
    sum_deprived_items >= 1 ~ "1-2",
    sum_deprived_items == 0 ~ "0"
  )) |> 
  group_by(country, r_sum_deprived_items, under_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, r_sum_deprived_items) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = r_sum_deprived_items, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_arop) |> 
  ggplot(aes(x = under_arop, y = sum_deprived_items, fill = under_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

Deprivace bez výdajů

hh_r_silc_2023_national_arop |> 
  group_by(country, sum_deprived_items_wo_expenses, under_national_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, sum_deprived_items_wo_expenses) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = sum_deprived_items_wo_expenses, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_national_arop) |> 
  ggplot(aes(x = under_national_arop, y = sum_deprived_items_wo_expenses, 
             fill = under_national_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, sum_deprived_items_wo_expenses, under_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, sum_deprived_items_wo_expenses) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = sum_deprived_items_wo_expenses, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_arop) |> 
  ggplot(aes(x = under_arop, y = sum_deprived_items_wo_expenses, 
             fill = under_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country) |> 
  summarise(
    cor_eu_arop_deprivation = cor(under_arop, sum_deprived_items, 
                                  use = "pairwise.complete.obs", method = "spearman"), 
    cor_national_arop_deprivation = cor(under_national_arop, sum_deprived_items, 
                                        use = "pairwise.complete.obs", method = "spearman")
  ) |> 
  knitr::kable(digits = 2)
country cor_eu_arop_deprivation cor_national_arop_deprivation
Austria 0.17 0.31
Belgium 0.14 0.27
Bulgaria 0.46 0.30
Croatia 0.51 0.48
Cyprus 0.35 0.36
Czechia 0.37 0.28
Denmark 0.15 0.19
Estonia 0.34 0.32
Finland 0.25 0.27
France 0.28 0.33
Germany 0.23 0.27
Greece 0.53 0.43
Hungary 0.41 0.31
Ireland 0.15 0.32
Italy 0.26 0.27
Latvia 0.43 0.36
Lithuania 0.39 0.34
Luxembourg 0.13 0.36
Malta 0.20 0.21
Netherlands 0.15 0.27
Poland 0.38 0.32
Portugal 0.43 0.34
Romania 0.44 0.33
Slovakia 0.35 0.31
Slovenia 0.32 0.33
Spain 0.33 0.33
Sweden 0.25 0.26

Rozdíly v AROP podle typu domácnosti

Typ bydlení

bydleni_data <- hh_r_silc_2023_arop %>% 
  group_by(r_country, r_tenure_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(r_tenure_status)) %>% 
  mutate(r_tenure_status = factor(r_tenure_status, 
                                  levels = c("Owner", "Tenant"), 
                                  labels = c("Majitelé", "Nájemníci"))) 
                                   
ggplot(bydleni_data, aes(x = r_tenure_status, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "% domácností pod evropskou hranicí chudoby") + 
  coord_flip() +
  theme_paq()

save_plot(last_plot(), 
          "figs/arop/tenants.png")
hh_r_silc_2023_arop %>% 
  group_by(country, r_tenure_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(r_tenure_status)) %>% 
  ggplot(., aes(x = r_tenure_status, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

# # arrange(pct_under_arop) %>% 
#   knitr::kable(., digits = 2, col.names = c("Country", "Tenure", "% under EU AROP"))

Typ domácnosti

typ_domacnosti_data <- hh_r_silc_2023_arop %>% 
  group_by(r_country, typ_domacnosti) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  # filter(!is.na(tenure_status)) %>% 
  mutate(typ_domacnosti = factor(typ_domacnosti, levels = c("Ostatní", "Samoživitel/ka s dětmi", "Samostatně žijící senior", "Dvojice seniorů", "Úplná domácnost s dětmi")))

ggplot(typ_domacnosti_data, aes(x = typ_domacnosti, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "% domácností pod evropskou hranicí chudoby") + 
  coord_flip() +
  theme_paq()

save_plot(last_plot(),
          "figs/arop/typ_hh.png")
hh_r_silc_2023_arop %>% 
  group_by(r_country, low_work_intensity) %>% 
  mutate(low_work_intensity = as_factor(low_work_intensity)) |> 
  mutate(low_work_intensity = factor(low_work_intensity, 
          levels = c("Not applicable", "Low work intensity", "No low work intensity"), 
          labels = c("Domácnosti 65+", "Domácnosti s nízkou pracovní intenzitou", 
                     "Ekonomicky aktivní domácnosti\n(bez nízké pracovní intenzity)")
  )) |> 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  # filter(!is.na(tenure_status)) %>% 
  ggplot(aes(x = low_work_intensity, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "% domácností pod evropskou hranicí chudoby") + 
  coord_flip() +
  theme_paq()

save_plot(last_plot(),
          "figs/arop/typ_ea.png")
hh_r_silc_2023_arop %>% 
  group_by(country, typ_domacnosti) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  # filter(!is.na(tenure_status)) %>% 
  ggplot(., aes(x = typ_domacnosti, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

Region

hh_r_silc_2023_arop %>% 
  group_by(r_country, region_typ) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(region_typ)) %>% 
  ggplot(., aes(x = region_typ, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  theme_paq()

hh_r_silc_2023_arop %>% 
  group_by(country, region_typ) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(region_typ)) %>% 
  ggplot(., aes(x = region_typ, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

Ekonomická aktivita

hh_r_silc_2023_arop |> 
  group_by(r_country, econ_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(econ_status)) %>% 
  ggplot(., aes(x = econ_status, y = pct_under_arop, 
                fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  theme_paq()

hh_r_silc_2023_arop |> 
  group_by(country, econ_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(econ_status)) %>% 
  ggplot(., aes(x = econ_status, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

Ekon. aktivní podle vzdělání (domácnosti bez 65+, vzdělání referenční osoby)

vzdelani_data <- hh_r_silc_2023_arop %>% 
  # filter(hh_old == "Bez 65+") %>% 
  mutate(rr_education = fct_case_when(
    r_education %in% c("First stage tertiary", "Second stage tertiary") ~ "Vysokoškolské",
    r_education %in% c("Pre-primary", "Primary", "Lower secondary", 
    "Upper secondary", "Post-secondary non-tertiary") ~ "Střední a nižší"
  )) %>% 
  group_by(r_country, rr_education) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(rr_education))

ggplot(vzdelani_data, aes(x = rr_education, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  theme_paq()

hh_r_silc_2023_arop %>% 
  filter(hh_old == "Bez 65+") %>% 
  mutate(rr_education = fct_case_when(
    r_education %in% c("Pre-primary", "Primary") ~ "Základní a nedokončené základní",
    r_education %in% c("Lower secondary", "Upper secondary") ~ "Střední",
    r_education %in% c("Post-secondary non-tertiary", "First stage tertiary", 
                       "Second stage tertiary") ~ "Vysokoškolské"
  )) %>% 
  group_by(country, rr_education) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(rr_education)) %>% 
  ggplot(., aes(x = rr_education, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

##### Small multiple chart

bind_rows(
  vzdelani_data |> 
    ungroup() |> 
    rename(category = rr_education) |> 
    mutate(indicator = "Vzdělání"),
  bydleni_data |> 
    ungroup() |> 
    rename(category = r_tenure_status) |> 
    mutate(indicator = "Typ bydlení")
) |> 
  ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  facet_wrap(indicator~., scales = "free") + 
  coord_flip()

g1 <- typ_domacnosti_data |> 
    ungroup() |> 
    rename(category = typ_domacnosti) |> 
    mutate(indicator = "Typ domácnosti") |> 
    ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
    geom_bar(stat = "identity", position = "dodge") + 
    coord_flip() + 
    labs(x = "", y = "% domácností", fill = "", 
          title = "typ domácnosti") + 
    theme(legend.position = "top") + 
    theme_paq() + 
    scale_fill_manual(values = paleta_kategoricka(2))

g2 <- vzdelani_data |> 
    ungroup() |> 
    rename(category = rr_education) |> 
    mutate(indicator = "Vzdělání") |> 
    ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
    geom_bar(stat = "identity", position = "dodge") + 
    coord_flip() + 
    labs(x = "", y = "% domácností", fill = "", 
          title = "vzdělání") + 
    theme(legend.position = "top") + 
    theme_paq() + 
    theme_paq() + 
    scale_fill_manual(values = paleta_kategoricka(2))

g3 <- bydleni_data |> 
    ungroup() |> 
    rename(category = r_tenure_status) |> 
    mutate(indicator = "Typ bydlení") |> 
    ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
    geom_bar(stat = "identity", position = "dodge") + 
    coord_flip() + 
    labs(x = "", y = "% domácností", fill = "", 
          title = "typ bydlení") + 
    theme(legend.position = "top") + 
    theme_paq() + 
    theme_paq() + 
    scale_fill_manual(values = paleta_kategoricka(2))

g1 + (g2 / g3) + 
  plot_layout(guides = 'collect') & 
  theme(legend.position='bottom')

save_plot(last_plot(), "figs/arop/cr_chudoba_skupiny.png")

Změna od 2018

tar_load(r_silc_2019)

hh_r_silc_2019 <- r_silc_2019 %>% 
  group_by(country, hh_id) %>% 
  mutate(
    n_retired = sum(econ_status == "Retired", na.rm = TRUE), 
    n_employed = sum(econ_status == "Employed", na.rm = TRUE), 
    n_adults = sum(age >= 18), 
    n_old_age = sum(age >= 65),
    income_disposable = if_else(income_disposable < 0, 0, income_disposable),  
    income_disposable_eqi = if_else(income_disposable_eqi < 0, 0, income_disposable_eqi)
  ) %>% 
  slice(1) %>% 
  ungroup() %>% 
  mutate(across(where(is.character), ~haven::as_factor(.x))) %>% 
  # filter out EU countries only
  filter(!country %in% c("NO", "RS", "CH")) %>% 
  mutate(country = fct_case_when(
    country == "AT" ~ "Austria",
    country == "BE" ~ "Belgium",
    country == "BG" ~ "Bulgaria",
    country == "CY" ~ "Cyprus",
    country == "CZ" ~ "Czechia",
    country == "DE" ~ "Germany",
    country == "DK" ~ "Denmark",
    country == "EE" ~ "Estonia",
    country == "EL" ~ "Greece",
    country == "ES" ~ "Spain",
    country == "FI" ~ "Finland",
    country == "FR" ~ "France",
    country == "HR" ~ "Croatia",
    country == "HU" ~ "Hungary",
    country == "IE" ~ "Ireland", 
    country == "IT" ~ "Italy",
    country == "LT" ~ "Lithuania",
    country == "LU" ~ "Luxembourg",
    country == "LV" ~ "Latvia",
    country == "MT" ~ "Malta",
    country == "NL" ~ "Netherlands",
    country == "PL" ~ "Poland", 
    country == "PT" ~ "Portugal", 
    country == "RO" ~ "Romania",
    country == "SE" ~ "Sweden",
    country == "SI" ~ "Slovenia",
    country == "SK" ~ "Slovakia"
  )) %>% 
  mutate(
    hh_retired = fct_case_when(
      n_retired == n_persons ~ "Plně důchodcovská domácnost", 
      n_retired > 0 ~ "Domácnost s důchodcem",
      n_retired == 0 ~ "Domácnost bez důchodců"
    ), 
    hh_old = fct_case_when(
      n_old_age == n_persons ~ "Všichni 65+",
      n_old_age > 0 ~ "Alespoň jeden 65+",
      n_old_age == 0 ~ "Bez 65+"
    ),
    typ_domacnosti = fct_case_when(
      n_adults == 2 & n_children > 0 ~ "Úplná domácnost s dětmi",
      n_adults == 1 & n_children > 0 ~ "Samoživitel/ka s dětmi",
      n_adults == 2 & hh_retired == "Plně důchodcovská domácnost" ~ "Dvojice seniorů",
      n_adults == 1 & hh_retired == "Plně důchodcovská domácnost" ~ "Samostatně žijící senior",
      TRUE ~ "Ostatní"
    )
  )

exchange_rates <- read_excel("data/exchange_rates.xlsx", sheet = 3, skip = 8) %>% 
  select(currency = TIME, exchange_rate_2018 = `2018`) %>% 
  filter(!is.na(currency)) %>% 
  mutate(country = case_when(
    currency == "Bulgarian lev" ~ "Bulgaria",
    currency == "Czech koruna" ~ "Czechia",
    currency == "Danish krone" ~ "Denmark",
    currency == "Hungarian forint" ~ "Hungary",
    currency == "Polish zloty" ~ "Poland",
    currency == "Romanian leu" ~ "Romania",
    currency == "Swedish krona" ~ "Sweden"
  )) %>% 
  filter(!is.na(country)) %>% 
  mutate(exchange_rate_2018 = as.numeric(exchange_rate_2018))

ppp_data <- read_excel("data/power_purchasing_parity_2decimals.xlsx") %>% 
  select(country = Country, ppp_2018 = `2018`)

ppp_adjusted <- left_join(ppp_data, exchange_rates, by = "country") %>% 
  mutate(ppp_2018_adjusted = if_else(
    !is.na(exchange_rate_2018), 
    ppp_2018 / exchange_rate_2018,
    ppp_2018
  )) %>% 
  select(country, ppp_2018_adjusted) 

hh_r_silc_2019_ppp <- left_join(hh_r_silc_2019, ppp_adjusted, by = "country") %>% 
  mutate(
    income_disposable_eqi_ppp = income_disposable_eqi / ppp_2018_adjusted
  )

EU_MEDIAN_PPP_2018 <- wtd.quantile(hh_r_silc_2019_ppp$income_disposable_eqi_ppp,
                              hh_r_silc_2019_ppp$hh_cross_weight, 0.5)  
EU_MEDIAN_60PCT_2018 <- EU_MEDIAN_PPP_2018 * 0.6

hh_r_silc_2019_arop <- hh_r_silc_2019_ppp %>% 
  mutate(under_arop = income_disposable_eqi_ppp < EU_MEDIAN_60PCT_2018)

# hh_r_silc_2019_arop %>% 
#   group_by(country) %>% 
#   summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
#   arrange(pct_under_arop) %>% 
#   knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP (2018)"))
full_join(
  hh_r_silc_2019_arop %>% 
  group_by(country) %>% 
  summarise(pct_under_arop_2018 = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE)
            * 100), 
  hh_r_silc_2023_arop %>% 
  group_by(country) %>% 
  summarise(pct_under_arop_2022 = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE)
            * 100), 
  by = "country"
) %>% 
  mutate(diff = pct_under_arop_2022 - pct_under_arop_2018) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under AROP (2018)", 
                                            "% under AROP (2022)", 
                                            "Difference 2022-2018"))
Country % under AROP (2018) % under AROP (2022) Difference 2022-2018
Austria 7.19 6.43 -0.76
Belgium 6.13 3.96 -2.16
Bulgaria 66.41 59.87 -6.54
Croatia 47.60 42.35 -5.25
Cyprus 13.07 13.87 0.80
Czechia 26.42 21.68 -4.74
Denmark 7.05 7.45 0.40
Estonia 37.84 39.24 1.40
Finland 8.47 10.35 1.88
France 7.30 11.14 3.84
Germany 10.96 10.84 -0.13
Greece 50.86 48.06 -2.80
Hungary 62.12 55.85 -6.27
Ireland 5.11 4.73 -0.38
Italy 19.70 17.92 -1.78
Latvia 49.71 46.01 -3.70
Lithuania 49.29 41.26 -8.02
Luxembourg 5.65 3.12 -2.54
Malta 17.00 17.39 0.39
Netherlands 7.38 7.49 0.11
Poland 40.59 26.87 -13.72
Portugal 38.91 37.70 -1.22
Romania 72.69 51.73 -20.96
Slovakia 50.07 51.33 1.25
Slovenia 17.95 14.79 -3.16
Spain 23.06 20.14 -2.92
Sweden 13.06 15.21 2.14

Souvislost mezi AROP a materiální deprivací

Evropská hranice AROP

hh_r_silc_2023_national_arop %>% 
  group_by(r_country, under_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_arop = factor(under_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod EU hranicí", 
                                        "Nad EU hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, under_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq() + 
  labs(x = "", y = "")

hh_r_silc_2023_national_arop %>% 
  group_by(country, under_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_arop = factor(under_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod EU hranicí", 
                                        "Nad EU hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, under_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq() + 
  labs(x = "", y = "")

hh_r_silc_2023_national_arop %>% 
  mutate(under_arop = factor(under_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad EU hranicí ohrožení chudobou",
                                        "Pod EU hranicí ohrožení chudobou"))) %>% 
  group_by(r_country, sum_deprived_items, under_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

hh_r_silc_2023_national_arop %>% 
  mutate(under_arop = factor(under_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad EU hranicí ohrožení chudobou",
                                        "Pod EU hranicí ohrožení chudobou"))) %>% 
  group_by(country, sum_deprived_items, under_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

Národní hranice AROP

hh_r_silc_2023_national_arop %>% 
  group_by(r_country, under_national_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_national_arop = factor(under_national_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod národní hranicí", 
                                        "Nad národní hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, under_national_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_national_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq()

hh_r_silc_2023_national_arop %>% 
  group_by(country, under_national_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_national_arop = factor(under_national_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod národní hranicí", 
                                        "Nad národní hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, under_national_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_national_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

hh_r_silc_2023_national_arop %>% 
  mutate(under_national_arop = factor(under_national_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad národní hranicí ohrožení chudobou",
                                        "Pod národní hranicí ohrožení chudobou"))) %>% 
  group_by(r_country, sum_deprived_items, under_national_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

hh_r_silc_2023_national_arop %>% 
  mutate(under_national_arop = factor(under_national_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad národní hranicí ohrožení chudobou",
                                        "Pod národní hranicí ohrožení chudobou"))) %>% 
  group_by(country, sum_deprived_items, under_national_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

Korelace mezi podílem mediánového příjmu a materiální deprivací

Celá EU
recode_term <- function(x){
  fct_case_when(
    x == "under_eu_arop" ~ "Under EU AROP",
    x == "under_eu_poverty" ~ "Under EU poverty line (50% median)",
    x == "under_eu_70_boundary" ~ "Under EU 70% median",
    x == "under_national_arop" ~ "Under national AROP",
    x == "under_national_poverty" ~ "Under national poverty line (50% median)",
    x == "under_national_70_boundary" ~ "Under national 70% median",
    x == "severe_material_social_deprivation" ~ "Severe material and social deprivation",
    x == "sum_deprived_items" ~ "Number of deprived items"
  )
}

hh_r_silc_2023_national_arop %>% 
  select(under_eu_arop = under_arop, 
         under_eu_poverty, 
         under_eu_70_boundary,
         under_national_poverty,
         under_national_arop, 
         under_national_70_boundary = under_70_boundary,
         severe_material_social_deprivation,
         sum_deprived_items) %>% 
  mutate(across(everything(), as.numeric)) %>% 
  correlate(use = "pairwise.complete.obs", method = "pearson") %>% 
  select(term, 
         `Severe material and social deprivation` = severe_material_social_deprivation, 
         `Number of deprived items` = sum_deprived_items) %>% 
  mutate(term = recode_term(term)) %>% 
  arrange(term) %>% 
  filter(!term %in% c("Severe material and social deprivation",
                     "Number of deprived items")) %>% 
  gt() %>% 
  fmt_number(decimals = 3) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Number of deprived items`, 
      rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
    )
  ) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Severe material and social deprivation`, 
      rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
    )
  )
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.224 0.377
Under EU poverty line (50% median) 0.229 0.355
Under EU 70% median 0.218 0.386
Under national AROP 0.221 0.326
Under national poverty line (50% median) 0.200 0.274
Under national 70% median 0.228 0.358
ČR vs zbytek EU
tables <- purrr::map(c("Czechia", "Rest of EU"), function(x) {
  hh_r_silc_2023_national_arop %>% 
    mutate(r_country = if_else(country == "Czechia", "Czechia", "Rest of EU")) %>% 
    filter(r_country == x) %>% 
    select(r_country, 
         under_eu_arop = under_arop, 
         under_eu_poverty, 
         under_eu_70_boundary,
         under_national_poverty,
         under_national_arop, 
         under_national_70_boundary = under_70_boundary,
         severe_material_social_deprivation,
         sum_deprived_items) %>% 
    mutate(across(where(is.logical) | where(is.factor), as.numeric)) %>% 
    correlate(use = "pairwise.complete.obs", method = "pearson") %>% 
    select(term, 
         `Severe material and social deprivation` = severe_material_social_deprivation, 
         `Number of deprived items` = sum_deprived_items) %>% 
    mutate(term = recode_term(term)) %>% 
    arrange(term) %>% 
    filter(!term %in% c("Severe material and social deprivation",
                     "Number of deprived items")) %>% 
    gt() %>% 
  fmt_number(decimals = 3) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Number of deprived items`, 
      rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
    )
  ) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Severe material and social deprivation`, 
      rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
    )
  ) %>% 
  tab_header(
    title = x
  )
})

purrr::walk(tables, print)
Czechia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.209 0.382
Under EU poverty line (50% median) 0.223 0.335
Under EU 70% median 0.169 0.378
Under national AROP 0.228 0.334
Under national poverty line (50% median) 0.207 0.255
Under national 70% median 0.212 0.372
Rest of EU
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.225 0.377
Under EU poverty line (50% median) 0.229 0.355
Under EU 70% median 0.221 0.387
Under national AROP 0.221 0.325
Under national poverty line (50% median) 0.199 0.274
Under national 70% median 0.229 0.358
Jednotlivé státy
countries <- unique(hh_r_silc_2023_national_arop$country)
tables <- purrr::map(countries, function(x) {
  hh_r_silc_2023_national_arop %>% 
    filter(country == x) %>% 
    select(country, 
         under_eu_arop = under_arop, 
         under_eu_poverty, 
         under_eu_70_boundary,
         under_national_poverty,
         under_national_arop, 
         under_national_70_boundary = under_70_boundary,
         severe_material_social_deprivation,
         sum_deprived_items) %>% 
    mutate(across(where(is.logical) | where(is.factor), as.numeric)) %>% 
    correlate(use = "pairwise.complete.obs", method = "pearson") %>% 
    select(term, 
         `Severe material and social deprivation` = severe_material_social_deprivation, 
         `Number of deprived items` = sum_deprived_items) %>% 
    mutate(term = recode_term(term)) %>% 
    arrange(term) %>% 
    filter(!term %in% c("Severe material and social deprivation",
                     "Number of deprived items")) %>% 
    gt() %>% 
  fmt_number(decimals = 3) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Number of deprived items`, 
      rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
    )
  ) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Severe material and social deprivation`, 
      rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
    )
  ) %>% 
  tab_header(
    title = x
  )
})

purrr::walk(tables, print)
Austria
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.125 0.175
Under EU poverty line (50% median) 0.063 0.101
Under EU 70% median 0.172 0.249
Under national AROP 0.194 0.320
Under national poverty line (50% median) 0.169 0.241
Under national 70% median 0.192 0.358
Belgium
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.148 0.172
Under EU poverty line (50% median) 0.085 0.093
Under EU 70% median 0.208 0.282
Under national AROP 0.224 0.301
Under national poverty line (50% median) 0.181 0.213
Under national 70% median 0.261 0.377
Bulgaria
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.267 0.423
Under EU poverty line (50% median) 0.287 0.427
Under EU 70% median 0.244 0.402
Under national AROP 0.273 0.322
Under national poverty line (50% median) 0.245 0.264
Under national 70% median 0.299 0.380
Cyprus
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.144 0.357
Under EU poverty line (50% median) 0.173 0.296
Under EU 70% median 0.167 0.414
Under national AROP 0.154 0.368
Under national poverty line (50% median) 0.164 0.299
Under national 70% median 0.161 0.409
Czechia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.209 0.382
Under EU poverty line (50% median) 0.223 0.335
Under EU 70% median 0.169 0.378
Under national AROP 0.228 0.334
Under national poverty line (50% median) 0.207 0.255
Under national 70% median 0.212 0.372
Germany
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.154 0.234
Under EU poverty line (50% median) 0.114 0.173
Under EU 70% median 0.177 0.274
Under national AROP 0.176 0.272
Under national poverty line (50% median) 0.146 0.221
Under national 70% median 0.202 0.317
Denmark
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.111 0.156
Under EU poverty line (50% median) 0.074 0.105
Under EU 70% median 0.155 0.200
Under national AROP 0.153 0.198
Under national poverty line (50% median) 0.111 0.156
Under national 70% median 0.162 0.223
Estonia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.134 0.319
Under EU poverty line (50% median) 0.137 0.316
Under EU 70% median 0.126 0.321
Under national AROP 0.144 0.319
Under national poverty line (50% median) 0.133 0.238
Under national 70% median 0.140 0.324
Greece
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.310 0.499
Under EU poverty line (50% median) 0.348 0.498
Under EU 70% median 0.268 0.482
Under national AROP 0.363 0.452
Under national poverty line (50% median) 0.344 0.398
Under national 70% median 0.353 0.474
Spain
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.246 0.343
Under EU poverty line (50% median) 0.224 0.300
Under EU 70% median 0.249 0.364
Under national AROP 0.245 0.343
Under national poverty line (50% median) 0.224 0.301
Under national 70% median 0.249 0.365
Finland
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.106 0.222
Under EU poverty line (50% median) 0.046 0.131
Under EU 70% median 0.153 0.303
Under national AROP 0.116 0.249
Under national poverty line (50% median) 0.060 0.156
Under national 70% median 0.158 0.317
France
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.223 0.309
Under EU poverty line (50% median) 0.160 0.219
Under EU 70% median 0.268 0.384
Under national AROP 0.250 0.358
Under national poverty line (50% median) 0.191 0.264
Under national 70% median 0.273 0.414
Croatia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.200 0.458
Under EU poverty line (50% median) 0.237 0.484
Under EU 70% median 0.174 0.424
Under national AROP 0.279 0.491
Under national poverty line (50% median) 0.292 0.464
Under national 70% median 0.249 0.491
Hungary
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.227 0.370
Under EU poverty line (50% median) 0.266 0.405
Under EU 70% median 0.183 0.324
Under national AROP 0.268 0.340
Under national poverty line (50% median) 0.258 0.300
Under national 70% median 0.303 0.406
Ireland
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.082 0.137
Under EU poverty line (50% median) 0.044 0.083
Under EU 70% median 0.172 0.255
Under national AROP 0.202 0.311
Under national poverty line (50% median) 0.101 0.173
Under national 70% median 0.210 0.360
Italy
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.186 0.272
Under EU poverty line (50% median) 0.170 0.236
Under EU 70% median 0.184 0.288
Under national AROP 0.187 0.278
Under national poverty line (50% median) 0.174 0.246
Under national 70% median 0.184 0.292
Lithuania
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.183 0.370
Under EU poverty line (50% median) 0.202 0.363
Under EU 70% median 0.168 0.374
Under national AROP 0.201 0.340
Under national poverty line (50% median) 0.202 0.291
Under national 70% median 0.200 0.359
Luxembourg
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.105 0.153
Under EU poverty line (50% median) 0.093 0.114
Under EU 70% median 0.107 0.165
Under national AROP 0.186 0.353
Under national poverty line (50% median) 0.196 0.324
Under national 70% median 0.185 0.364
Latvia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.222 0.405
Under EU poverty line (50% median) 0.236 0.406
Under EU 70% median 0.194 0.387
Under national AROP 0.251 0.379
Under national poverty line (50% median) 0.235 0.325
Under national 70% median 0.256 0.403
Malta
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.138 0.200
Under EU poverty line (50% median) 0.132 0.162
Under EU 70% median 0.157 0.236
Under national AROP 0.156 0.217
Under national poverty line (50% median) 0.129 0.179
Under national 70% median 0.159 0.245
Netherlands
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.060 0.129
Under EU poverty line (50% median) 0.023 0.085
Under EU 70% median 0.148 0.235
Under national AROP 0.181 0.288
Under national poverty line (50% median) 0.063 0.132
Under national 70% median 0.185 0.341
Poland
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.175 0.355
Under EU poverty line (50% median) 0.192 0.336
Under EU 70% median 0.162 0.345
Under national AROP 0.193 0.329
Under national poverty line (50% median) 0.195 0.289
Under national 70% median 0.180 0.350
Portugal
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.219 0.416
Under EU poverty line (50% median) 0.236 0.387
Under EU 70% median 0.203 0.422
Under national AROP 0.249 0.365
Under national poverty line (50% median) 0.225 0.299
Under national 70% median 0.235 0.387
Romania
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.300 0.425
Under EU poverty line (50% median) 0.310 0.418
Under EU 70% median 0.285 0.427
Under national AROP 0.279 0.351
Under national poverty line (50% median) 0.247 0.316
Under national 70% median 0.312 0.399
Sweden
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.137 0.245
Under EU poverty line (50% median) 0.112 0.191
Under EU 70% median 0.156 0.285
Under national AROP 0.152 0.261
Under national poverty line (50% median) 0.118 0.202
Under national 70% median 0.154 0.285
Slovenia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.212 0.369
Under EU poverty line (50% median) 0.174 0.263
Under EU 70% median 0.212 0.419
Under national AROP 0.214 0.372
Under national poverty line (50% median) 0.184 0.271
Under national 70% median 0.210 0.419
Slovakia
term Severe material and social deprivation Number of deprived items
Under EU AROP 0.174 0.319
Under EU poverty line (50% median) 0.251 0.387
Under EU 70% median 0.140 0.262
Under national AROP 0.276 0.351
Under national poverty line (50% median) 0.239 0.259
Under national 70% median 0.268 0.367

Gini

GINI:
- vzít ekvivalizované příjmy domácností - verifikovat si, zda nám sedí GINI s veřejnými publikacemi Eurostat
- ✅ definice ekonomicky aktivní populace - srovnat bez GINI jen na nich
- ✅ volnější - vyřadit plně důchodecké domácnosti - srovnání států bez nich
- ✅ tvrdší - vyřadit domácnosti s alespoň 1 důchodeckým příjmem
- udělat 2D mapy států podle:
- ✅ celkový výše příjmů aktivní populace (PPS) x nerovnosti příjmů
- Česko vyjde v kvadrantu malé příjmy, omezené (ale ne nejmenší nerovnosti)
- nice to have, když to bude fungovat:
- lepší popis distribuce toho GINI - jiný ukazatel nerovnosti, zda není daný tím, že GINI hodně reflektuje nerovnost ve středu?
- srovnání s majetkovým GINI
- vývoj GINIs

Gini podle eurostatu: https://ec.europa.eu/eurostat/databrowser/view/ilc_di12/default/table?lang=en

gini_2023 <- hh_r_silc_2023 %>% 
  group_by(country) %>% 
  summarise(
    gini = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100, 
    gini_neeqi = Gini(income_disposable, hh_cross_weight, na.rm = TRUE) * 100
  )

gini_2023 %>% 
  mutate(country = as.character(country)) %>% 
  arrange(country) %>% 
  select(-gini_neeqi) %>% 
  knitr::kable(., digits = 2)
country gini
Austria 29.71
Belgium 25.63
Bulgaria 37.82
Croatia 32.43
Cyprus 30.74
Czechia 25.41
Denmark 29.14
Estonia 34.21
Finland 27.82
France 29.25
Germany 30.18
Greece 31.61
Hungary 29.58
Ireland 29.03
Italy 32.33
Latvia 36.23
Lithuania 38.14
Luxembourg 30.66
Malta 34.81
Netherlands 27.34
Poland 28.78
Portugal 35.20
Romania 30.24
Slovakia 20.94
Slovenia 25.49
Spain 31.90
Sweden 31.39

Důchodci podle ekon. statusu

gini_2023_wo_pensioners <- hh_r_silc_2023 %>% 
  filter(!hh_retired %in% c("Plně důchodcovská domácnost", "Domácnost s důchodcem")) %>% 
  group_by(country) %>% 
  summarise(
    gini_no_pensioners = Gini(income_disposable_eqi, hh_cross_weight, 
                              na.rm = TRUE) * 100, 
    gini_no_pensioners_neeqi = Gini(income_disposable, hh_cross_weight, 
                              na.rm = TRUE) * 100, 
  )
  
gini_2023_wo_full_pensioner_hh <- hh_r_silc_2023 %>% 
  filter(hh_retired != "Plně důchodcovská domácnost") %>% 
  group_by(country) %>% 
  summarise(
    gini_no_full_pensioners = Gini(income_disposable_eqi, hh_cross_weight, 
                                   na.rm = TRUE) * 100, 
    gini_no_full_pensioners_neeqi = Gini(income_disposable, hh_cross_weight, 
                                   na.rm = TRUE) * 100, 
  )
  
gini_2023 %>% 
  full_join(gini_2023_wo_pensioners, by = "country") %>% 
  full_join(gini_2023_wo_full_pensioner_hh, by = "country") %>% 
  select(-ends_with("neeqi")) %>% 
  mutate(
    diff_wo_pensioners = gini_no_pensioners - gini, 
    diff_wo_full_pensioners = gini_no_full_pensioners - gini
  ) %>% 
  mutate(across(where(is.numeric), ~round(.x, 2))) %>% 
  rename(`Stát` = country, `Gini` = gini, 
         `Gini bez domácností s důchodcem` = gini_no_pensioners, 
         `Gini bez důchodcovských domácností` = gini_no_full_pensioners, 
         `Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners, 
         `Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>% 
  datatable(options = list(
    paging =FALSE,
    searching=FALSE,
    pageLength = 50))
Gini z neekvivalizovaného příjmu
gini_2023 %>% 
  full_join(gini_2023_wo_pensioners, by = "country") %>% 
  full_join(gini_2023_wo_full_pensioner_hh, by = "country") %>% 
  select(country, ends_with("neeqi")) %>% 
  mutate(
    diff_wo_pensioners = gini_no_pensioners_neeqi - gini_neeqi, 
    diff_wo_full_pensioners = gini_no_full_pensioners_neeqi - gini_neeqi
  ) %>% 
  mutate(across(where(is.numeric), ~round(.x, 2))) %>% 
  rename(`Stát` = country, `Gini` = gini_neeqi, 
         `Gini bez domácností s důchodcem` = gini_no_pensioners_neeqi, 
         `Gini bez důchodcovských domácností` = gini_no_full_pensioners_neeqi, 
         `Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners, 
         `Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>% 
  datatable(options = list(
    paging =FALSE,
    searching = FALSE,
    pageLength = -1))

Důchodci podle věku

gini_2023_wo_old <- hh_r_silc_2023 %>% 
  filter(!hh_old %in% c("Všichni 65+", "Alespoň jeden 65+")) %>% 
  group_by(country) %>% 
  summarise(gini_no_pensioners = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100)
  
gini_2023_wo_full_old_hh <- hh_r_silc_2023 %>% 
  filter(hh_old != "Všichni 65+") %>% 
  group_by(country) %>% 
  summarise(gini_no_full_pensioners = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100)
  
gini_2023 %>% 
  select(-ends_with("neeqi")) %>% 
  full_join(gini_2023_wo_old, by = "country") %>% 
  full_join(gini_2023_wo_full_old_hh, by = "country") %>% 
  mutate(
    diff_wo_pensioners = gini_no_pensioners - gini, 
    diff_wo_full_pensioners = gini_no_full_pensioners - gini
  ) %>% 
  mutate(across(where(is.numeric), ~round(.x, 2))) %>% 
  rename(`Stát` = country, `Gini` = gini, 
         `Gini bez domácností s důchodcem` = gini_no_pensioners, 
         `Gini bez důchodcovských domácností` = gini_no_full_pensioners, 
         `Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners, 
         `Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>% 
  datatable(options = list(
    paging =FALSE,
    searching = FALSE,
    pageLength = -1))
data_2d <- hh_r_silc_2023_ppp %>% 
  group_by(country) %>% 
  summarise(median_income_disposable_eqi_ppp = 
              wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.5)) %>% 
  ungroup %>% 
  left_join(., gini_2023, by = "country")

AVG_INCOME <- mean(data_2d$median_income_disposable_eqi_ppp)
AVG_GINI <- mean(data_2d$gini)

data_2d %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko")) |> 
  ggplot(aes(x = gini, y = median_income_disposable_eqi_ppp)) + 
  geom_hline(yintercept = AVG_INCOME, colour = "gray60") + 
  geom_vline(xintercept = AVG_GINI, colour = "gray60") + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  labs(x = "Gini koeficient", y = "Mediánový ekvivalizovaný příjem domácnosti v PPP") + 
  theme_paq()

save_plot(last_plot(), 
          "figs/arop/gini.png")

bez důchodců

data_2d_wo_old <- hh_r_silc_2023_ppp %>% 
  filter(!hh_old %in% c("Všichni 65+", "Alespoň jeden 65+")) %>% 
  group_by(country) %>% 
  summarise(median_income_disposable_eqi_ppp = 
              wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.5)) %>% 
  ungroup %>% 
  left_join(., gini_2023_wo_old, by = "country")

AVG_INCOME <- mean(data_2d_wo_old$median_income_disposable_eqi_ppp)
AVG_GINI <- mean(data_2d_wo_old$gini_no_pensioners)

data_2d_wo_old %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko")) |> 
  ggplot(aes(x = gini_no_pensioners, y = median_income_disposable_eqi_ppp)) + 
  geom_hline(yintercept = AVG_INCOME, colour = "gray60") + 
  geom_vline(xintercept = AVG_GINI, colour = "gray60") + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  labs(x = "Gini koeficient", y = "Mediánový ekvivalizovaný příjem domácnosti v PPP") + 
  theme_paq()

save_plot(last_plot(), 
          "figs/arop/gini_bez_duchodcu.png")
# https://rev01ution.red/wp-content/uploads/2024/03/global-wealth-databook-2023-ubs.pdf

gini_property <- tribble(
  ~country, ~gini_property, 
  "Austria", 76.1,
  "Belgium", 59.6,
  "Bulgaria", 70.6, 
  "Croatia", 69.6,
  "Cyprus", 78.4,
  "Czechia", 78.5, 
  "Denmark", 73.6,
  "Estonia", 73.1,
  "Finland", 72.4,
  "France", 70.3,
  "Germany", 77.2,
  "Greece", 68.1,
  "Hungary", 67.7,
  "Ireland", 79.9,
  "Italy", 67.8,
  "Latvia", 80.4,
  "Lithuania", 70.6,
  "Luxembourg", 64.8,
  "Malta", 60.9,
  "Netherlands", 78.8,
  "Poland", 68.4,
  "Portugal", 70.3,
  "Romania", 69.3,
  "Slovakia", 50.8,
  "Slovenia", 64.4,
  "Spain", 68.3,
  "Sweden", 87.4
)

full_join(gini_2023, gini_property, by = "country") |> 
  mutate(country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )) |> 
  ggplot(aes(x = gini, y = gini_property)) + 
  geom_point() + 
  geom_vline(xintercept = mean(gini_2023$gini), colour = "gray60") +
  geom_hline(yintercept = mean(gini_property$gini_property), colour = "gray60") + 
  geom_text_repel(aes(label = country)) + 
  # geom_smooth(method = "lm") + 
  labs(x = "Gini příjmů", y = "Gini majetku", caption = "Zdroj: EU-SILC 2023 pro gini index příjmů, Global Wealth Databook 2023 pro Gini majetku") + 
  theme_paq()

save_plot(last_plot(), "figs/arop/gini_income_property.png")